(in-package :lilu-apropos)

(defparameter *default-iapropos-max-result-length* 300
  "The max length of the result")

(defstruct (search-option (:type list))
  name
  type
  default-value)

;;;
;;; base iteractive apropos
;;;

(defclass iapropos ()
  ((options :initform nil
            :initarg :options)
   (option-values :type (or null list)
                  :initform nil
                  :reader iapropos-option-values)
   (cached-regexp-scanners :initform nil)
   (max-result-length :initform *default-iapropos-max-result-length*
                      :initarg :max-result-length
                      :accessor iapropos-max-result-length)
   (result-overflow-p :initform nil
                      :reader iapropos-result-overflow-p)
   (cached-matched-objects :initform nil
                           :reader iapropos-matched-objects)
   (obj->string-fn :initarg :obj->string-fn
                   :initform nil)
   (obj->symbol-fn :initarg :obj->symbol-fn
                   :initform nil)
   (match-object-fn :initarg :match-object-fn
                    :initform nil)
   (remove-duplicate-p :initarg :remove-duplicate-p
                       :initform t)
   (sorting-symbol-p :initarg :sorting-symbol-p
                     :initform nil)))

(defmethod initialize-instance :after ((iapropos iapropos) &key &allow-other-keys)
  (iapropos-reset-option-values iapropos))

(defgeneric iapropos-option (iapropos option-name &optional error-p)
  (:method ((iapropos iapropos) option-name &optional error-p)
    (with-slots (options) iapropos
      (anaphora:aif (assoc option-name options)
                    anaphora:it
                    (if error-p
                        (error "Unknow option ~A" option-name)
                        t)))))

(defgeneric iapropos-option-value (iapropos option-name &optional error-p)
  (:method ((iapropos iapropos) option-name &optional error-p)
    (with-slots (option-values) iapropos
      (anaphora:aif (getf option-values option-name)
                    anaphora:it
                    (if (iapropos-option iapropos option-name error-p)
                        nil
                        nil)))))

(defgeneric iapropos-set-option-value (iapropos option-name value &optional update-p)
  (:method ((iapropos iapropos) option-name value &optional (update-p t))
    (let ((change (list option-name (iapropos-option-value iapropos option-name t) value)))
      (unless (equal (second change) (third change))
        (with-slots (option-values) iapropos
          (setf (getf option-values option-name) value))
        (when update-p
          (iapropos-update-search iapropos (list change)))
        change))))

(defmethod (setf iapropos-option-value) (val (iapropos iapropos) option-name)
  (iapropos-set-option-value iapropos option-name val t))

(defgeneric iapropos-set-option-values (iapropos &rest args &key reset-p &allow-other-keys)
  (:method ((iapropos iapropos) &rest args &key reset-p &allow-other-keys)
    (when reset-p
      (iapropos-reset-option-values iapropos nil))
    (with-slots (option-values) iapropos
      (let ((changes
              (remove nil
                      (loop for (opt val) on (alexandria:remove-from-plist args :reset-p) by #'cddr
                            collect (iapropos-set-option-value iapropos opt val nil)))))
        (iapropos-update-search iapropos changes)))))

(defgeneric iapropos-reset-option-values (iapropos &optional update-p)
  (:method ((iapropos iapropos) &optional (update-p t))
    (with-slots (option-values options) iapropos
      (let ((changes
              (remove nil (loop for opt in options
                                collect
                                (iapropos-set-option-value iapropos
                                                           (search-option-name opt)
                                                           (search-option-default-value opt)
                                                           nil)))))
        (when update-p
          (iapropos-update-search iapropos changes))
        changes))))

(defgeneric iapropos-update-search (iapropos changes)
  (:method :around ((iapropos iapropos) changes)
    (declare (ignore changes))
    (with-slots (cached-matched-objects) iapropos
      (setf cached-matched-objects (call-next-method))
      (iapropos-sort-matched-objects iapropos)))
  (:method :after ((iapropos iapropos) changes)
    )
  (:method :before ((iapropos iapropos) changes)
    (flet ((make-regex-scanner (search-text)
             (let ((scanner))
               (handler-bind ((cl-ppcre:ppcre-syntax-error
                                #'(lambda (condition)
                                    (declare (ignore condition))
                                    (setf scanner nil))))
                 (setf scanner (when (and search-text (string/= search-text ""))
                                 (cl-ppcre:create-scanner
                                  search-text :case-insensitive-mode t))))
               scanner)))
      (with-slots (cached-regexp-scanners options option-values) iapropos
        (loop for change in changes
              for option-name = (car change)
              for option = (iapropos-option iapropos option-name)
              do
                 (when (eql (search-option-type option) :regex)
                   (anaphora:awhen (getf option-values (search-option-name option))
                     (setf (getf cached-regexp-scanners
                                 (search-option-name option))
                           (make-regex-scanner anaphora:it)))))))))

(defgeneric iapropos-sort-matched-objects (iapropos)
  (:method ((iapropos iapropos))
    (with-slots (remove-duplicate-p sorting-symbol-p
                 obj->symbol-fn obj->string-fn cached-matched-objects)
        iapropos
      (let ((swank::*buffer-package* (find-package :common-lisp-user))
            (swank::*buffer-readtable* *readtable*))
        (setf cached-matched-objects
              (sort
               (if remove-duplicate-p
                   (remove-duplicates cached-matched-objects)
                   cached-matched-objects)
               (if sorting-symbol-p
                   #'(lambda (x y)
                       (cond ((and (symbol-package x) (symbol-package y)) (swank::present-symbol-before-p x y))
                             ((symbol-package x) t)
                             ((symbol-package y) nil)
                             (t (string< (symbol-name x) (symbol-name y)))))
                   #'string-lessp)
               :key (if sorting-symbol-p
                        obj->symbol-fn
                        obj->string-fn)))))))

(defgeneric iapropos-matched-object-packages (iapropos)
  (:method ((iapropos iapropos))
    (with-slots (obj->symbol-fn result-overflow-p) iapropos
        (when obj->symbol-fn
          (values (remove nil (remove-duplicates (mapcar #'(lambda (o)
                                                             (symbol-package (funcall obj->symbol-fn o)))
                                                         (iapropos-matched-objects iapropos))))
                  result-overflow-p)))))

(defgeneric iapropos-match-object-p (iapropos object)
  (:method ((iapropos iapropos) object)
    (with-slots (match-object-fn) iapropos
        (funcall match-object-fn iapropos object))))

(defgeneric iapropos-describe-object (iapropos object))

;;;
;;;
;;;

(defun iapropos-maching-objects (iapropos all &key fn match-fn)
  (with-slots (max-result-length result-overflow-p remove-duplicate-p match-object-fn) iapropos
    (let ((matching-fn (or match-fn match-object-fn))
          (out)
          (i 0))
      (setf result-overflow-p nil)
      (block iter
        (dolist (element all)
          (let ((object (if fn (funcall fn element) element)))
            (when (= i max-result-length)
              (when remove-duplicate-p
                (setf out (remove-duplicates out))
                (setf i (length out)))
              (when (= i max-result-length)
                (setf result-overflow-p t)
                (return-from iter)))
            (when (funcall matching-fn iapropos object)
              (push object out)
              (incf i)))))
      out)))

(defmacro when-option ((option option-values) &body body)
  `(anaphora:aif (getf ,option-values ,option)
                 (let ((value anaphora:it))
                   ,@body)
                 t))

(defmacro when-option-yes/no ((option option-values) &body body)
  `(when-option (,option ,option-values)
     (or (eql value :any)
         (eql value (if (progn ,@body)
                        :yes :no)))))

(defmacro when-option-regex ((option cached-regexp-scanners) &body body)
  `(anaphora:aif (getf ,cached-regexp-scanners ,option)
                 (let ((scanner anaphora:it))
                   ,@body)
                 t))
